home *** CD-ROM | disk | FTP | other *** search
/ Chip 2007 January, February, March & April / Chip-Cover-CD-2007-02.iso / Pakiet bezpieczenstwa / mini Pentoo LiveCD 2006.1 / mpentoo-2006.1.iso / livecd.squashfs / usr / lib / perl5 / 5.8.7 / Test / Harness / Point.pm < prev    next >
Encoding:
Perl POD Document  |  2006-04-25  |  3.5 KB  |  153 lines
  1. # -*- Mode: cperl; cperl-indent-level: 4 -*-
  2. package Test::Harness::Point;
  3.  
  4. use strict;
  5. use vars qw($VERSION);
  6. $VERSION = '0.01';
  7.  
  8. =head1 NAME
  9.  
  10. Test::Harness::Point - object for tracking a single test point
  11.  
  12. =head1 SYNOPSIS
  13.  
  14. One Test::Harness::Point object represents a single test point.
  15.  
  16. =head1 CONSTRUCTION
  17.  
  18. =head2 new()
  19.  
  20.     my $point = new Test::Harness::Point;
  21.  
  22. Create a test point object.
  23.  
  24. =cut
  25.  
  26. sub new {
  27.     my $class = shift;
  28.     my $self  = bless {}, $class;
  29.  
  30.     return $self;
  31. }
  32.  
  33. my $test_line_regex = qr/
  34.     ^
  35.     (not\ )?               # failure?
  36.     ok\b
  37.     (?:\s+(\d+))?         # optional test number
  38.     \s*
  39.     (.*)                  # and the rest
  40. /ox;
  41.  
  42. =head1 from_test_line( $line )
  43.  
  44. Constructor from a TAP test line, or empty return if the test line
  45. is not a test line.
  46.  
  47. =cut
  48.  
  49. sub from_test_line  {
  50.     my $class = shift;
  51.     my $line = shift or return;
  52.  
  53.     # We pulverize the line down into pieces in three parts.
  54.     my ($not, $number, $extra) = ($line =~ $test_line_regex ) or return;
  55.  
  56.     my $point = $class->new;
  57.     $point->set_number( $number );
  58.     $point->set_ok( !$not );
  59.  
  60.     if ( $extra ) {
  61.         my ($description,$directive) = split( /(?:[^\\]|^)#/, $extra, 2 );
  62.         $description =~ s/^- //; # Test::More puts it in there
  63.         $point->set_description( $description );
  64.         if ( $directive ) {
  65.             $point->set_directive( $directive );
  66.         }
  67.     } # if $extra
  68.  
  69.     return $point;
  70. } # from_test_line()
  71.  
  72. =head1 ACCESSORS
  73.  
  74. Each of the following fields has a getter and setter method.
  75.  
  76. =over 4
  77.  
  78. =item * ok
  79.  
  80. =item * number
  81.  
  82. =cut
  83.  
  84. sub ok              { my $self = shift; $self->{ok} }
  85. sub set_ok          {
  86.     my $self = shift;
  87.     my $ok = shift;
  88.     $self->{ok} = $ok ? 1 : 0;
  89. }
  90. sub pass {
  91.     my $self = shift;
  92.  
  93.     return ($self->ok || $self->is_todo || $self->is_skip) ? 1 : 0;
  94. }
  95.  
  96. sub number          { my $self = shift; $self->{number} }
  97. sub set_number      { my $self = shift; $self->{number} = shift }
  98.  
  99. sub description     { my $self = shift; $self->{description} }
  100. sub set_description {
  101.     my $self = shift;
  102.     $self->{description} = shift;
  103.     $self->{name} = $self->{description}; # history
  104. }
  105.  
  106. sub directive       { my $self = shift; $self->{directive} }
  107. sub set_directive   {
  108.     my $self = shift;
  109.     my $directive = shift;
  110.  
  111.     $directive =~ s/^\s+//;
  112.     $directive =~ s/\s+$//;
  113.     $self->{directive} = $directive;
  114.  
  115.     my ($type,$reason) = ($directive =~ /^\s*(\S+)(?:\s+(.*))?$/);
  116.     $self->set_directive_type( $type );
  117.     $reason = "" unless defined $reason;
  118.     $self->{directive_reason} = $reason;
  119. }
  120. sub set_directive_type {
  121.     my $self = shift;
  122.     $self->{directive_type} = lc shift;
  123.     $self->{type} = $self->{directive_type}; # History
  124. }
  125. sub set_directive_reason {
  126.     my $self = shift;
  127.     $self->{directive_reason} = shift;
  128. }
  129. sub directive_type  { my $self = shift; $self->{directive_type} }
  130. sub type            { my $self = shift; $self->{directive_type} }
  131. sub directive_reason{ my $self = shift; $self->{directive_reason} }
  132. sub reason          { my $self = shift; $self->{directive_reason} }
  133. sub is_todo {
  134.     my $self = shift;
  135.     my $type = $self->directive_type;
  136.     return $type && ( $type eq 'todo' );
  137. }
  138. sub is_skip {
  139.     my $self = shift;
  140.     my $type = $self->directive_type;
  141.     return $type && ( $type eq 'skip' );
  142. }
  143.  
  144. sub diagnostics     {
  145.     my $self = shift;
  146.     return @{$self->{diagnostics}} if wantarray;
  147.     return join( "\n", @{$self->{diagnostics}} );
  148. }
  149. sub add_diagnostic  { my $self = shift; push @{$self->{diagnostics}}, @_ }
  150.  
  151.  
  152. 1;
  153.